Windows Expert/Windows Expert.iso/windownt/perlnt.zip/eg/h2ph.cmd

OS/2 REXX Batch file | 1993-07-25 | 5KB | 217 lines

@rem = '-*- Perl -*-';
@rem = '
@echo off
perl -S %0.cmd %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
';

#$perlincl = 'c:/win32app/ingr/perl/inc';
$perlincl = 'e:/perl-4.036/inc';

$incdir = 'd:/mstools/h';

@isatype = split(' ',<<END);
    char    uchar    u_char
    short    ushort    u_short
    int    uint    u_int
    long    ulong    u_long
    FILE
END

@isatype{@isatype} = (1) x @isatype;

#@ARGV = ('-') unless @ARGV;

opendir(D, $incdir) || die "can'd open $incdir directory";
@dirs = readdir (D);
closedir D;
@ARGV = grep (/^.*\.h$/i, @dirs);

foreach $file (@ARGV) {
    if ($file eq '-') {
    open(IN, "-");
    open(OUT, ">-");
    }
    else {
    ($outfile = $file) =~ s/\.h$/.ph/i || next;
    print "$file -> $outfile\n";
    if ($file =~ m|^(.*)/|) {
        $dir = $1;
        if (!-d "$perlincl/$dir") {
        mkdir("$perlincl/$dir",0777);
        }
    }
    open(IN,"$incdir/$file")
        || ((warn "Can't open $incdir/$file: $!\n"),next);
    open(OUT,">$perlincl/$outfile")
        || die "Can't create $outfile: $!\n";
    }
    while (<IN>) {
    chop;
    while (/\\$/) {
        chop;
        $_ .= <IN>;
        chop;
    }
    if (s:/\*:\200:g) {
        s:\*/:\201:g;
        s/\200[^\201]*\201//g;    # delete single line comments
        if (s/\200.*//) {        # begin multi-line comment?
        $_ .= '/*';
        $_ .= <IN>;
        redo;
        }
    }
    if (s/^#\s*//) {
        if (s/^define\s+(\w+)//) {
        $name = $1;
        $new = '';
        s/\s+$//;
        if (s/^\(([\w,\s]*)\)//) {
            $args = $1;
            if ($args ne '') {
            foreach $arg (split(/,\s*/,$args)) {
                $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
                $curargs{$arg} = 1;
            }
            $args =~ s/\b(\w)/\$$1/g;
            $args = "local($args) = \@_;\n$t    ";
            }
            s/^\s+//;
            do expr();
            $new =~ s/(["\\])/\\$1/g;
            if ($t ne '') {
            $new =~ s/(['\\])/\\$1/g;
            print OUT $t,
              "eval 'sub $name {\n$t    ${args}eval \"$new\";\n$t}';\n";
            }
            else {
            print OUT "sub $name {\n    ${args}eval \"$new\";\n}\n";
            }
            %curargs = ();
        }
        else {
            s/^\s+//;
            do expr();
            $new = 1 if $new eq '';
            if ($t ne '') {
            $new =~ s/(['\\])/\\$1/g;
            print OUT $t,"eval 'sub $name {",$new,";}';\n";
            }
            else {
            print OUT $t,"sub $name {",$new,";}\n";
            }
        }
        }
        elsif (/^include\s+<(.*)>/) {
        ($incl = $1) =~ s/\.h$/.ph/;
        print OUT $t,"require '$incl';\n";
        }
        elsif (/^ifdef\s+(\w+)/) {
        print OUT $t,"if (defined &$1) {\n";
        $tab += 4;
        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
        }
        elsif (/^ifndef\s+(\w+)/) {
        print OUT $t,"if (!defined &$1) {\n";
        $tab += 4;
        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
        }
        elsif (s/^if\s+//) {
        $new = '';
        do expr();
        print OUT $t,"if ($new) {\n";
        $tab += 4;
        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
        }
        elsif (s/^elif\s+//) {
        $new = '';
        do expr();
        $tab -= 4;
        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
        print OUT $t,"}\n${t}elsif ($new) {\n";
        $tab += 4;
        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
        }
        elsif (/^else/) {
        $tab -= 4;
        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
        print OUT $t,"}\n${t}else {\n";
        $tab += 4;
        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
        }
        elsif (/^endif/) {
        $tab -= 4;
        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
        print OUT $t,"}\n";
        }
    }
    }
    print OUT "1;\n";
}

sub expr {
    while ($_ ne '') {
    s/^(\s+)//        && do {$new .= ' '; next;};
    s/^(0x[0-9a-fA-F]+)//    && do {$new .= $1; next;};
    s/^(\d+)//        && do {$new .= $1; next;};
    s/^("(\\"|[^"])*")//    && do {$new .= $1; next;};
    s/^'((\\"|[^"])*)'//    && do {
        if ($curargs{$1}) {
        $new .= "ord('\$$1')";
        }
        else {
        $new .= "ord('$1')";
        }
        next;
    };
    s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
        $new .= '$sizeof';
        next;
    };
    s/^([_a-zA-Z]\w*)//    && do {
        $id = $1;
        if ($id eq 'struct') {
        s/^\s+(\w+)//;
        $id .= ' ' . $1;
        $isatype{$id} = 1;
        }
        elsif ($id eq 'unsigned') {
        s/^\s+(\w+)//;
        $id .= ' ' . $1;
        $isatype{$id} = 1;
        }
        if ($curargs{$id}) {
        $new .= '$' . $id;
        }
        elsif ($id eq 'defined') {
        $new .= 'defined';
        }
        elsif (/^\(/) {
        s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i;    # cheat
        $new .= " &$id";
        }
        elsif ($isatype{$id}) {
        if ($new =~ /{\s*$/) {
            $new .= "'$id'";
        }
        elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
            $new =~ s/\(\s*$//;
            s/^[\s*]*\)//;
        }
        else {
            $new .= $id;
        }
        }
        else {
        $new .= ' &' . $id;
        }
        next;
    };
    s/^(.)//            && do {$new .= $1; next;};
    }
}
__END__
:endofperl